perm filename PT[MSS,LCS] blob
sn#238781 filedate 1976-09-28 generic text, type T, neo UTF8
00100 SUBROUTINE PT2
00200 INTEGER VALID
00300 DIMENSION VALID(6),NBAR(36)
00400 DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
00500 C QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600
00700 C ADD MORE TO VALID LATER *****
00800 COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
00900 1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
01000 COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
01100 COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
01200 COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
01300 1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
01400 EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
01500 1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
01600 C TRNSP'S Bb, F, BBb, A, G, Eb.
01700 NAMQ='AAAAA'
01800 LL=0
01900 NBAR(1)=0
02000 5 FORMAT(F,2I)
02100 IF(RS.NE.'OLD')GO TO 2000
02200 CALL GETFIL('PARTS')
02300 CALL FASTIN(RSTFAC,128)
02400 CALL FASTIN(KPN,JJ2)
02500 CALL FASTIN(Q,JPQ)
02600 2000 TYPE 144
02700 144 FORMAT(' STAFF SIZE, TRANSP. '$)
02800 ACCEPT 5,RSTJ2,LL
02900 IF(MOD(LL,7).EQ.0)GO TO 140
03000 DO 40 L=1,6
03100 40 IF(LL.EQ.VALID(L))GO TO 140
03200 TYPE 240
03300 GO TO 2000
03400 240 FORMAT(' THIS TRANSP NOT OFFERED')
03500 140 IF(IPG)GO TO 41
03600 IF(RSTJ2.EQ.0)GO TO 41
03700 RA=RSTJ2/RPSZ(1)
03800 DO 141 K=1,JPG
03900 141 RPSZ(K)=RPSZ(K)*RA
04000
04100 41 IF(RSTJ2.EQ.0)RSTJ2=.9
04200 L=JJ2-2
04300 TR=LL
04400 IF(LL.NE.0)CALL TRNSP(L,TR)
04500 I=L
04600 KK=1
04700 C FOUND A BAR LINE
04800 ENDLN=ENDL(JJ)
04900 C FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
05000
05100 NA=1000
05200 N=0
05300 TYPE 90,JJ
05400 RA=0
05500 90 FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
05600 ZLINE=QLINE
05700 9 KL=0
05800 XLINE=ZLINE
05900 J=0
06000 LL=0
06100 DO 8 K=1,JJ
06200 IF(RN(K).LT.XLINE)GO TO 8
06300 KP=K-KL
06400 C NUMBER OF BARS, THIS LINE
06500 CC TYPE 89,KP
06600 KL=K
06700 J=J+1
06800 IF(IV(J).NE.KP)LL=-1
06900 IV(J)=KP
07000 XLINE=RN(K)+ZLINE
07100 IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
07200 8 CONTINUE
07300 IF(LL)TYPE 108,RA,(IV(K),K=1,J)
07400 IF(RT)GO TO 105
07500 108 FORMAT(F6.2,8(3I3,1X))
07600 CC TYPE 108
07700 CC108 FORMAT(/)
07800 CC89 FORMAT('+',I3,$)
07900 IF(J.GT.NA)GO TO 107
08000 IF(N.EQ.0)GO TO 105
08100 C SKIP IF FIRST TIME
08200 IF(N.NE.KP)GO TO 106
08300 IF(J.EQ.NA)GO TO 105
08400 106 RT=.05
08500 C SHRINK OR EXPAND?
08600 RA=RA+RT
08700 ZLINE=QLINE*RS/RA
08800 GO TO 9
08900 1107 TYPE 111,KA
09000 107 FORMAT(' CAN''T DO IT!')
09100 TYPE 107
09200 105 TYPE 104,J
09300 104 FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
09400 KA=0
09500 ACCEPT 5,RA,N,KL
09600 C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
09700 IF(KL.NE.0)GO TO 110
09800 C FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
09900 C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
10000 IF(RA.EQ.0)GO TO 11
10100 IF(ZLINE.EQ.QLINE)RS=J
10200 NA=RA
10300 RT=NA-RA
10400 IF(RT)GO TO 109
10500 RA=RA-.6
10600 C CHECK THIS ↑↑↑ NUMBER!
10700 IF(N.EQ.0)GO TO 90
10800 109 ZLINE=QLINE*RS/RA
10900 GO TO 9
11000
11100 111 FORMAT(36I)
11200 110 REREAD 111,NBAR
11300 911 DO 112 K=36,1,-1
11400 KP=NBAR(K)
11500 KA=KA+KP
11600 112 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
11700 IF(KA.NE.JJ)GO TO 1107
11800 C MISMATCH!
11900 N=26-2*MOD(KL-1,12)
12000 IF(N.EQ.26)N=0
12100 C TO SPACE OUT STAVES VERTICALLY
12200
12300 11 RA=0
12400 IF(IPG)GO TO 811
12500 IF(NBAR(1).NE.0)GO TO 811
12600 DO 711 K=1,36
12700 IF(K.GT.J)IV(K)=0
12800 711 NBAR(K)=IV(K)
12900 GO TO 911
13000 811 JEND=-1
13100 XLINE=ZLINE
13200 CLEF=-99
13300 JSLUR=0
13400 LC=1
13500 SIG=CLEF
13600 HX=2
13700 SP=2.45
13800 C DEFAULT VERT. SPACE UNITS
13900 IF(N.EQ.0)GO TO 100
14000 C SPACED OUT DEPENDING ON NUM OF LINES
14100 HX=N
14200 SP=SP+(HX-2.)*.11
14300 100 KL=1
14400 IF(JEND.EQ.0)GO TO 1000
14500 103 FORMAT(' TYPE OUTPUT FILE NAME ',$)
14600 102 FORMAT(A5)
14700 TYPE 103
14800 ACCEPT 102,NAMX
14900 IF(NAMX.EQ.' ')NAMX=NAMQ
15000 NAMZ=NAMX
15100 NPG=1
15200 RA=JPG*RSTJ2
15300 MPG=10./RA
15400 C MPG=NUM OF BRACES PER PAGE.
15500 SPG=12./MPG
15600 C SPG IS SPACE TO BE SET ABOVE STAFF 0
15700 IF(LOOKF(NAMX).GE.0)GO TO 88
15800 TYPE 88,NAMX
15900 ACCEPT 102,L
16000 IF(L.EQ.'N')GO TO 103
16100 88 FORMAT(' WRITE OVER FILE ',A5,'???? '$)
16200 1000 KP=1
16300 JEND=0
16400 C FLAG FOR PAGE END - WHEN -1
16500 RT=2
16600 J=KK
16700 HGT=HX*2.
16800 LB=0
16900 MTR1=-1
17000
17100 DO 1 K=KK,I
17200 N=KPN(K)
17300 IF(Q(N+1).NE.4)GO TO 1
17400 IF(KA.EQ.0)GO TO 334
17500 LB=LB+1
17600 C BAR COUNTER
17700 IF(NBAR(LC).GT.LB)GO TO 1
17800 C FOR SPECIFIED BARS
17900 LC=LC+1
18000 LB=0
18100 IF(NBAR(LC).NE.0)GO TO 335
18200 JEND=-1
18300 LC=LC+1
18400 GO TO 335
18500 334 IF(Q(N+3).LT.XLINE)GO TO 1
18600 C FOUND LAST BAR LINE.
18700 335 RX=0
18800 MTR1=-1
18900 MTR2=-1
19000 LL=KPN(K+1)
19100 C TO ADD METER AT END OF BAR
19200 RS=Q(LL+1)
19300 IF(RS.LE.4)GO TO 3
19400 IF(RS.EQ.18)MTR1=LL
19500 C WHAT ABOUT REHRSL NUMS, ETC??
19600 LL=KPN(K+2)
19700 RS=Q(LL+1)
19800 IF(RS.LE.4)GO TO 3
19900 IF(IPG)GO TO 4011
20000 IF(Q(LL+2).NE.Q(N+2))GO TO 4111
20100 4011 IF(RS.EQ.18)MTR2=LL
20200 LL=KPN(K+3)
20300 IF(IPG)GO TO 4211
20400 IF(Q(LL+2).NE.Q(N+2))GO TO 4111
20500 4211 IF(Q(LL+1).EQ.18)MTR2=LL
20600 4111 IF(MTR1.GT.0)GO TO 3
20700 MTR1=MTR2
20800 MTR2=-1
20900 C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
21000 3 JJ=KP
21100 C PUTS IN STAFF
21200 RS=3.
21300 IF(RT.NE.0)GO TO 331
21400 C NEXT FOR BOTTOM STAFF. PUTS IN SPACER.
21500 RS=6.
21600 331 IF(IPG)GO TO 411
21700 HX=8
21800 RZ=0
21900 RX=RT
22000 DO 611 JP=1,JPG
22100 RT=RSTNUM(JP)
22200 RS=3
22300 C WD CNT IS RS, HX IS CODE(8), ARRAYS AND JPG WERE SET UP IN MAIN.
22400 RR=0
22500 IF(JP.GT.1)GO TO 611
22550 IF(NAMX.EQ.NAMZ)GO TO 611
22600 RS=6
22700 RR=SPG
22800 C FOR SPACER ON STAFF 0
22900 611 CALL STAFF(RS,HX,RZ,RHGT(JP),RPSZ(JP),RZ,RZ,RR)
23000 HX=JPG
23100 RS=4.
23200 RT=0
23300 CALL STAFF(2.,RS,RZ,HX,RZ,RZ,RZ,RZ)
23400 IF(BRACK.NE.0)CALL STAFF(5.,RS,RZ,HX,RZ,RZ,BRACK,RZ)
23500 RT=RX
23600 GO TO 511
23700 411 CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
23800 HGT=HGT-HX
23900 511 IF(XLINE.EQ.ZLINE)GO TO 33
24000 IF(JEND)GO TO 60
24100 C FOR PREMATURE PAGE END
24200 IF(K.NE.I)GO TO 6
24300 IF(RT.EQ.0)GO TO 6
24400 60 IF(IPG.EQ.0)GO TO 6
24500 RX=RT
24600 RT=0
24700 CALL STAFF(6.,8.,0,0,0,0,1.,SP)
24800 C PUTS IN SPACER
24900 RT=RX
25000 6 IF(JSLUR.EQ.0)GO TO 2333
25100 CC LL=JSLUR
25200 CC JSLUR=0
25300 CALL JSL(JSLUR)
25400 1333 CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
25500 2333 IF(JSL2.EQ.0)GO TO 333
25600 CC LL=JSL2
25700 C FOR 2ND SLUR AT END OF LINE.
25800 CC JSL2=0
25900 CALL JSL(JSL2)
26000 GO TO 1333
26100 333 IF(CLEF.EQ.-99)GO TO 33
26200 C ONLY STAFF FOR FIRST LINE AT TOP.
26300 RX=10.*RSTJ2
26400 C THE SPACER
26500 LA=0
26600 IF(IPG)GO TO 3011
26700 LA=JPG
26800 3111 RT=RSTNUM(LA)
26900 LL=RT
27000 CLEF=RCLEF(LL)
27100 C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
27200 LA=LA-1
27300 3011 CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0)
27400 IF(SIG.EQ.-99)GO TO 3211
27500 RS=4.
27600 R5=SIG
27700 CC RX=CLEF
27800 CC IF(R5.LT.50)GO TO 332
27900 CC RX=IFIX((R5+50.)/100.)
28000 CC R5=R5-RX*100.
28100 C CLEF+SIG
28200 332 CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,CLEF,0,0)
28300 RX=12.*RSTJ2
28400 3211 IF(LA.GT.0)GO TO 3111
28500
28600 33 R4=RA
28700 R5=Q(N+3)
28800 RS=0
28900 R7=RT
29000 R8=RX
29100 R9=200.
29200 LL=0
29300 L=K-J+1
29400 CALL PTMOVE(Q,KPN(J))
29500 RA=R5
29600 31 IF(MTR1)GO TO 231
29700 LA=0
29800 IF(IPG)GO TO 5011
29900 LA=JPG
30000 5111 RT=RSTNUM(LA)
30100 C PUT METER ON ALL STAVES FOR PAGE LAYOUT
30200 LA=LA-1
30300 5011 R=200.0+2.23*RSTJ2
30400 CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
30500 C PUTS METER AFTER END OF STAFF
30600 IF(MTR2)GO TO 5211
30700 R=200.0+6.7*RSTJ2
30800 CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
30900 C PUTS COMPOSITE METER AFTER END OF STAFF
31000 5211 IF(LA.GT.0)GO TO 5111
31100 231 KB=KL
31200 131 DO 30 NA=KK,K
31300 KWDS(KP)=KB
31400 KP=KP+1
31500 JK=KPN(NA)
31600 R=Q(JK+1)
31700 IF(R.EQ.5)GO TO 135
31800 IF(R.NE.44)GO TO 35
31900 135 RR=Q(JK+6)
32000 IF(RR.LT.Q(JK+3))GO TO 635
32100 C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
32200 IF(RR.LT.199.)GO TO 37
32300 C CATCHES END OF SLUR AND VARIOUS LINES
32400 635 IF(R.NE.5)GO TO 37
32500 C TO PUT SLUR ON NEXT LINE.
32600 C*********** IS SOMETHING MISSING HERE???????? 4/76
32700 235 IF(JSLUR.NE.0)GO TO 435
32800 CC JSLUR=JK+4
32900 JSLUR=JSLX(JK)
33000 GO TO 535
33100 CC435 JSL2=JK+4
33200 435 JSL2=JSLX(JK)
33300 C FOR 2ND SLUR
33400 535 RR=201
33500 IF(Q(JK+8).LT.-1)RR=202
33600 Q(JK+6)=RR
33700 IF(R.EQ.5)GO TO 30
33800 GO TO 38
33900
34000 35 IF(R.NE.2)GO TO 36
34100 IF(Q(JK).LT.6.)GO TO 30
34200 RR=RIGHT(NA,-1)
34300 IF(RR.GE.199.)RR=RX
34400 Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
34500 C FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
34600 C CENTERS WHOLE REST
34700 GO TO 30
34800 36 IF(R.NE.3)GO TO 34
34900 CC RR=Q(JK+5)
35000 CC IF(Q(JK).LT.3)RR=0
35100 CC CLEF=AMOD(RR,100.0)
35200 CLEF=CLEFN(Q,JK)
35300 IF(IPG)GO TO 30
35400 LL=Q(JK+2)
35500 C GETS CLEF FOR PAGE LAYOUT
35600 RCLEF(LL)=CLEF
35700 GO TO 30
35800 34 IF(R.NE.17)GO TO 37
35900 SIG=Q(JK+5)
36000 IF(ABS(SIG).GT.100.)SIG=-99
36100 C DO NOT REPEAT KSIG MADE UP OF NATURALS.
36200 CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
36300 CXX CLEF # IN P6 WITH KEY SIGS.
36400 C NEXT CHANGES CODE NUM BACK TO ORIGINAL
36500 37 IF(R.LT.33)GO TO 30
36600 38 Q(JK+1)=R/11.
36700 30 KB=KPN(NA+1)-KPN(NA)+KB
36800
36900 CALL PSHFT(KK,K)
37000 RS=RT
37100 LL='J'
37200 R4=0
37300 R5=200
37400 NA=L
37500 L=KP-JJ
37600 CALL PTMOVE(RN,KWDS(JJ))
37700 DO 47 JJ2=JJ,KP
37800 LL=KWDS(JJ2)
37900 AA=RN(LL+1)
38000 IF(AA.NE.10.AND.AA.NE.16)GO TO 347
38100 DO 147 NN=JJ2+1,KP
38200 MM=KWDS(NN)
38300 IF(RN(MM+1).NE.16)GO TO 147
38400 C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
38500 IF(RN(MM).EQ.8)GO TO 47
38600 C JUMP IF POS. IS ALREADY TAKEN CARE OF.
38700 IF(AA.EQ.10)GO TO 247
38800 C NEXT FOR TEXT FOLLOWING TEXT
38900 IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
39000 C JUMP IF ON DIFF. VERT. PLANE.
39100 AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
39200 C SETS MINIMUM SPACE.
39300 IF(RN(MM+3).LT.AA)RN(MM+3)=AA
39400 GO TO 47
39500 247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
39600 C CHECKS VERT. POS.
39700 AA=RN(LL+4)+7
39800 IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
39900 C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
40000 GO TO 47
40100 147 CONTINUE
40200 GO TO 47
40300 347 IF(AA.NE.5)GO TO 1047
40400 C TO IMPROVE SLUR PARAMETERS
40500 R8=RN(LL+8)
40600 IF(RN(LL).LT.6)R8=0
40700 IF(R8.GT.0)GO TO 47
40800 C JUMP IF A BRACKET
40900 R=RN(LL+6)
41000
41100 DO 647 NN=JJ2+1,KP
41200 MM=KWDS(NN)
41300 C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
41400 IF(RN(MM+1).NE.4)GO TO 647
41500 C FIND A BAR LINE
41600 IF(RN(MM+3).GT.199.)GO TO 647
41700 C IGNORE LAST BAR OR LINE.
41800 IF(RN(MM).GT.2)GO TO 647
41900 AA=ABS(RN(MM+3)-R)
42000 IF(AA.GT.1.)GO TO 647
42100 RN(LL+6)=R+4
42200 GO TO 47
42300 647 CONTINUE
42400
42500 R7=RN(LL+7)
42600 R9=R-RN(LL+3)+(R8+1.)*2.
42700 IF(R9.GT.7)GO TO 47
42800 C NO WORK NEEDED. IT'S LONG ENOUGH
42900 IF(RN(LL).GT.5)RN(LL+8)=-1
43000 R=1.
43100 IF(R7.LT.0)R=-R
43200 547 RN(LL+4)=RN(LL+4)+R
43300 RN(LL+5)=RN(LL+5)+R
43400 C WERE +AA ↑↑↑↑↑
43500 RN(LL+7)=R
43600 GO TO 47
43700 1047 IF(AA.NE.6)GO TO 47
43800 IF(RN(LL).LT.7)GO TO 47
43900 IF(RN(LL+9).GT.200.)RN(LL+9)=0
44000 C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
44100 47 CONTINUE
44200
44300 IF(K.EQ.I)GO TO 2
44400 L=NA
44500 J=K+1
44600 C SO IT DOESN'T GO THRU ALL DATA
44700 RT=RT-1
44800 XLINE=RA+ZLINE
44900 IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
45000 IF(IPG.EQ.0)GO TO 2
45100 C OMIT NEXT FOR PAGE LAYOUT ONLY
45200 10 IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
45300 1 IF(K.EQ.I)GO TO 3
45400 2 KWDS(KP)=KB
45500 J=1
45600 JJ2=KP+1
45700 JPQ=KB
45800 C WRITES 1 EXTRA WORD
45900 CALL PUTFIL(NAMX)
46000 LCNT=0
46100 NDPY=0
46200 CALL FASTOU(RSTFAC,128)
46300 CALL FASTOU(KWDS,JJ2)
46400 CALL FASTOU(RN,JPQ)
46500 TYPE 101,NAMX
46600 IF(KK.GE.I)CALL EXIT
46700 NAMX=NAMX+2
46800 IF(IPG)GO TO 6011
46900 NPG=NPG+1
47000 IF(NPG.LE.MPG)GO TO 6011
47100 NPG=1
47200 C RESET, UPDATE FILENAMES
47300 NAMX=NAMZ+256
47400 NAMZ=NAMX
47500 6011 NAMQ=NAMX
47600 CALL FINFIL
47700 GO TO 100
47800 101 FORMAT(1XA5)
47900 END
48000